home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clue.lha / clue / clx-patch.l < prev    next >
Lisp/Scheme  |  1989-07-12  |  4KB  |  113 lines
  1. ;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Patch-file:T -*-
  2.  
  3. ;;;
  4. ;;;             TEXAS INSTRUMENTS INCORPORATED
  5. ;;;                  P.O. BOX 2909
  6. ;;;                   AUSTIN, TEXAS 78769
  7. ;;;
  8. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  9. ;;;
  10. ;;; Permission is granted to any individual or institution to use, copy, modify,
  11. ;;; and distribute this software, provided that this complete copyright and
  12. ;;; permission notice is maintained, intact, in all copies and supporting
  13. ;;; documentation.
  14. ;;;
  15. ;;; Texas Instruments Incorporated provides this software "as is" without
  16. ;;; express or implied warranty.
  17. ;;;
  18.  
  19. ;;; Written 08/24/87 16:09:09 by OREN,
  20.  
  21. ;; Add an optional :WINDOW keyword parameter to create-window
  22.  
  23. (in-package 'xlib :use '(lisp))
  24.  
  25. ; From file REQUESTS.LISP#> X.CLX; SI:
  26. (defun create-window (&key
  27.               window
  28.               (parent (required-arg parent))
  29.               (x (required-arg x))
  30.               (y (required-arg y))
  31.               (width (required-arg width))
  32.               (height (required-arg height))
  33.               (depth 0) (border-width 0)
  34.               (class :copy) (visual :copy)
  35.               background border
  36.               bit-gravity gravity
  37.               backing-store backing-planes backing-pixel save-under
  38.               event-mask do-not-propagate-mask override-redirect
  39.               colormap cursor)
  40.   ;; Display is obtained from parent.  Only non-nil attributes are passed on in
  41.   ;; the request: the function makes no assumptions about what the actual protocol
  42.   ;; defaults are.  Width and height are the inside size, excluding border.
  43.   (declare (type (or null window) window)
  44.        (type window parent) ; required
  45.        (type int16 x y) ;required
  46.        (type card16 width height) ;required
  47.        (type card16 depth border-width)
  48.        (type (member :copy :input-output :input-only) class)
  49.        (type (or (member :copy) card29) visual)
  50.        (type (or null (member :none :parent-relative) pixel pixmap) background)
  51.        (type (or null (member :copy) pixel pixmap) border)
  52.        (type (or null bit-gravity) bit-gravity)
  53.        (type (or null win-gravity) gravity)
  54.        (type (or null (member :not-useful :when-mapped :always)) backing-store)
  55.        (type (or null pixel) backing-planes backing-pixel)
  56.        (type (or null event-mask) event-mask)
  57.        (type (or null device-event-mask) do-not-propagate-mask)
  58.        (type (or null (member :on :off)) save-under override-redirect)
  59.        (type (or null (member :copy) colormap) colormap)
  60.        (type (or null (member :none) cursor) cursor))
  61.   (declare-values window)
  62.   (let* ((display (window-display parent))
  63.      (window (or window (make-window)))
  64.      (wid (allocate-resource-id display window 'window))
  65.      back-pixmap back-pixel
  66.      border-pixmap border-pixel)
  67.     (setf (window-id window) wid
  68.       (window-display window) display)
  69.     (case background
  70.       ((nil) nil)
  71.       (:none (setq back-pixmap 0))
  72.       (:parent-relative (setq back-pixmap 1))
  73.       (otherwise
  74.        (if (type? background 'pixmap)
  75.        (setq back-pixmap (pixmap-id background))
  76.      (if (integerp background)
  77.          (setq back-pixel background)
  78.        (x-type-error background
  79.              '(or null (member :none :parent-relative) integer pixmap))))))
  80.     (case border
  81.       ((nil) nil)
  82.       (:copy (setq border-pixmap 1))
  83.       (otherwise
  84.        (if (type? border 'pixmap)
  85.        (setq border-pixmap (pixmap-id border))
  86.      (if (integerp border)
  87.          (setq border-pixel border)
  88.        (x-type-error border '(or null (member :copy) integer pixmap))))))
  89.     (when event-mask
  90.       (setq event-mask (encode-event-mask event-mask)))
  91.     (when do-not-propagate-mask
  92.       (setq do-not-propagate-mask (encode-device-event-mask do-not-propagate-mask)))
  93.  
  94.                         ;Make the request
  95.     (with-buffer-request (display *x-createwindow*)
  96.       (data depth)
  97.       (resource-id wid)
  98.       (window parent)
  99.       (int16 x y)
  100.       (card16 width height border-width)
  101.       ((member16 :copy :input-output :input-only) class)
  102.       (resource-id (if (eq visual :copy) 0 visual))
  103.       (mask ((or null card32) back-pixmap back-pixel border-pixmap border-pixel)
  104.         ((or null (member-vector *bit-gravity-vector*)) bit-gravity)
  105.         ((or null (member-vector *win-gravity-vector*)) gravity)
  106.         ((or null (member :not-useful :when-mapped :always)) backing-store)
  107.         ((or null card32)  backing-planes backing-pixel)
  108.         ((or null (member :off :on)) override-redirect save-under)
  109.         ((or null card32) event-mask do-not-propagate-mask)
  110.         ((or null (member %error :copy) colormap) colormap)
  111.         ((or null (member :none) cursor) cursor)))
  112.     window))
  113.